分析記録
Rikiya Honda
2022-11-30
準備
以下の通りにパッケージとデータセットを用意する。 すべてのコードは、githubに公開されています。
# load library ------------------------------------------------------------
pacman::p_load("tidyverse", "janitor", "stringr", "lubridate", "patchwork", "modelr")
# import dataset --------------------------------------------------------
path_to_github <- "https://raw.githubusercontent.com/Ricky-s-a/business_analysis/main/data/ST2187_coursework_dataset_2022_23.csv"
df_raw <- read_csv(path_to_github)データセットの基本情報
このデータセットは、row: x columns:となっている。
# inspect the dataset -----------------------------------------------------
glimpse(df_raw)## Rows: 51,290
## Columns: 24
## $ `Row ID` <dbl> 32298, 26341, 25330, 13524, 47221, 22732, 30570, 3119…
## $ `Order ID` <chr> "CA-2012-124891", "IN-2013-77878", "IN-2013-71249", "…
## $ `Order Date` <chr> "8/1/2019", "2/6/2020", "10/17/2020", "1/29/2020", "1…
## $ `Ship Date` <chr> "8/1/2019", "2/8/2020", "10/18/2020", "1/31/2020", "1…
## $ `Ship Mode` <chr> "Same Day", "Second Class", "First Class", "First Cla…
## $ `Customer ID` <chr> "RH-19495", "JR-16210", "CR-12730", "KM-16375", "RH-9…
## $ `Customer Name` <chr> "Rick Hansen", "Justin Ritter", "Craig Reiter", "Kath…
## $ Segment <chr> "Consumer", "Corporate", "Consumer", "Home Office", "…
## $ City <chr> "New York City", "Wollongong", "Brisbane", "Berlin", …
## $ State <chr> "New York", "New South Wales", "Queensland", "Berlin"…
## $ Country <chr> "United States", "Australia", "Australia", "Germany",…
## $ `Postal Code` <dbl> 10024, NA, NA, NA, NA, NA, NA, NA, 95823, 28027, 2230…
## $ Market <chr> "US", "APAC", "APAC", "EU", "Africa", "APAC", "APAC",…
## $ Region <chr> "East", "Oceania", "Oceania", "Central", "Africa", "O…
## $ `Product ID` <chr> "TEC-AC-10003033", "FUR-CH-10003950", "TEC-PH-1000466…
## $ Category <chr> "Technology", "Furniture", "Technology", "Technology"…
## $ `Sub-Category` <chr> "Accessories", "Chairs", "Phones", "Phones", "Copiers…
## $ `Product Name` <chr> "Plantronics CS510 - Over-the-Head monaural Wireless …
## $ Sales <dbl> 2309.650, 3709.395, 5175.171, 2892.510, 2832.960, 286…
## $ Quantity <dbl> 7, 9, 9, 5, 8, 5, 4, 6, 5, 13, 5, 5, 4, 7, 12, 4, 9, …
## $ Discount <dbl> 0.0, 0.1, 0.1, 0.1, 0.0, 0.1, 0.0, 0.0, 0.2, 0.4, 0.0…
## $ Profit <dbl> 762.1845, -288.7650, 919.9710, -96.5400, 311.5200, 76…
## $ `Shipping Cost` <dbl> 933.57, 923.63, 915.49, 910.16, 903.04, 897.35, 894.7…
## $ `Order Priority` <chr> "Critical", "Critical", "Medium", "Medium", "Critical…NAの数
すばらしいことに、postal codeにNAがあるだけで、そのほかにはまったくNAがない。
# the number of na
lapply(df_raw, function(n){sum(is.na(n))})## $`Row ID`
## [1] 0
##
## $`Order ID`
## [1] 0
##
## $`Order Date`
## [1] 0
##
## $`Ship Date`
## [1] 0
##
## $`Ship Mode`
## [1] 0
##
## $`Customer ID`
## [1] 0
##
## $`Customer Name`
## [1] 0
##
## $Segment
## [1] 0
##
## $City
## [1] 0
##
## $State
## [1] 0
##
## $Country
## [1] 0
##
## $`Postal Code`
## [1] 41296
##
## $Market
## [1] 0
##
## $Region
## [1] 0
##
## $`Product ID`
## [1] 0
##
## $Category
## [1] 0
##
## $`Sub-Category`
## [1] 0
##
## $`Product Name`
## [1] 0
##
## $Sales
## [1] 0
##
## $Quantity
## [1] 0
##
## $Discount
## [1] 0
##
## $Profit
## [1] 0
##
## $`Shipping Cost`
## [1] 0
##
## $`Order Priority`
## [1] 0データクレンジング
- コラムの名前を小文字にする
- いくつかの変数の作成（order_date, ship_date, order_year, order_month, ship_year, gap_date, profit_ratio)
# tidy dataset ------------------------------------------------------------
df_tidy <- df_raw %>%
clean_names()
# tidy
df <- df_tidy %>%
mutate(
order_date = as.Date(order_date, format = "%m/%d/%Y"),
ship_date = as.Date(ship_date, format = "%m/%d/%Y"),
order_year = year(order_date),
order_month = month(order_date),
ship_year = year(ship_date),
ship_month = month(ship_date),
split_tf = round(runif(nrow(df_tidy), min = 1, max = 5)),
gap_date = as.numeric(difftime(ship_date, order_date, units = "days")),
profit_ratio = profit/sales
) %>%
arrange(desc(order_date))
# show
glimpse(df)## Rows: 51,290
## Columns: 31
## $ row_id <dbl> 1783, 26535, 44025, 26333, 12929, 26335, 15693, 1787, 1…
## $ order_id <chr> "MX-2014-116267", "IN-2014-43550", "RS-2014-1460", "IN-…
## $ order_date <date> 2021-12-31, 2021-12-31, 2021-12-31, 2021-12-31, 2021-1…
## $ ship_date <date> 2022-01-03, 2022-01-01, 2022-01-02, 2022-01-03, 2022-0…
## $ ship_mode <chr> "Second Class", "First Class", "Second Class", "First C…
## $ customer_id <chr> "EB-13975", "ML-17395", "PB-9105", "JD-16150", "JG-1580…
## $ customer_name <chr> "Erica Bern", "Marina Lichtenstein", "Peter Bühler", "J…
## $ segment <chr> "Corporate", "Corporate", "Consumer", "Corporate", "Cor…
## $ city <chr> "São Paulo", "Jakarta", "Ufa", "Bangkok", "Maidenhead",…
## $ state <chr> "São Paulo", "Jakarta", "Bashkortostan", "Bangkok", "En…
## $ country <chr> "Brazil", "Indonesia", "Russia", "Thailand", "United Ki…
## $ postal_code <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 10009, …
## $ market <chr> "LATAM", "APAC", "EMEA", "APAC", "EU", "APAC", "EU", "L…
## $ region <chr> "South", "Southeast Asia", "EMEA", "Southeast Asia", "N…
## $ product_id <chr> "TEC-CO-10000137", "FUR-BO-10004679", "TEC-HEW-10004652…
## $ category <chr> "Technology", "Furniture", "Technology", "Furniture", "…
## $ sub_category <chr> "Copiers", "Bookcases", "Copiers", "Tables", "Phones", …
## $ product_name <chr> "Canon Wireless Fax, Color", "Safco Library with Doors,…
## $ sales <dbl> 1264.4660, 1091.2806, 865.6200, 1048.7313, 867.3000, 29…
## $ quantity <dbl> 5, 3, 6, 9, 5, 3, 3, 3, 2, 9, 4, 4, 4, 5, 2, 3, 3, 4, 2…
## $ discount <dbl> 0.002, 0.070, 0.000, 0.570, 0.000, 0.270, 0.100, 0.000,…
## $ profit <dbl> 301.4660, 46.9206, 51.8400, -1195.2387, 251.4000, 68.11…
## $ shipping_cost <dbl> 253.25, 243.11, 138.18, 86.86, 53.16, 52.11, 51.79, 51.…
## $ order_priority <chr> "High", "High", "High", "High", "Medium", "High", "Medi…
## $ order_year <dbl> 2021, 2021, 2021, 2021, 2021, 2021, 2021, 2021, 2021, 2…
## $ order_month <dbl> 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,…
## $ ship_year <dbl> 2022, 2022, 2022, 2022, 2022, 2022, 2022, 2022, 2022, 2…
## $ ship_month <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 12, 1, 1, 1, 12, 1, 1, 1,…
## $ split_tf <dbl> 3, 1, 3, 4, 3, 4, 3, 5, 3, 1, 1, 2, 3, 5, 5, 2, 2, 4, 2…
## $ gap_date <dbl> 3, 1, 2, 3, 5, 3, 2, 3, 4, 5, 0, 4, 4, 1, 0, 4, 5, 5, 5…
## $ profit_ratio <dbl> 0.23841369, 0.04299591, 0.05988771, -1.13969965, 0.2898…探索的データ分析
数値データの基本統計量
gap_date()（ship_date - order_date)で計算されている。 注目したいのは、salesの分布が非常に広いことである。上は、2.263848^{4}, 下は、0.444となっていることから、高額な買い物をする顧客と少額決済をする顧客がいることがわかる。
\[ profit = sales - cost \\ quantity \times price - cost) \]
であるため、分析の方向としては、どうしたらprofitを改善させることができるのかということを最終的な目標として設定したい。
discountに関しては内政変数であるため、その効果が実際にあったのかについての政策評価することもできるし、どうしたら利益率を改善できるのかについての政策提言もできるかもしれない。
# summary of numeric data
df %>%
select(where(is.numeric)) %>%
select(!ends_with(c("year", "month", "id", "tf", "code"))) %>%
summary()## sales quantity discount profit
## Min. : 0.444 Min. : 1.000 Min. :0.0000 Min. :-6599.98
## 1st Qu.: 30.759 1st Qu.: 2.000 1st Qu.:0.0000 1st Qu.: 0.00
## Median : 85.053 Median : 3.000 Median :0.0000 Median : 9.24
## Mean : 246.491 Mean : 3.477 Mean :0.1429 Mean : 28.61
## 3rd Qu.: 251.053 3rd Qu.: 5.000 3rd Qu.:0.2000 3rd Qu.: 36.81
## Max. :22638.480 Max. :14.000 Max. :0.8500 Max. : 8399.98
## shipping_cost gap_date profit_ratio
## Min. : 0.00 Min. :0.000 Min. :-4.73354
## 1st Qu.: 2.61 1st Qu.:3.000 1st Qu.: 0.00000
## Median : 7.79 Median :4.000 Median : 0.16918
## Mean : 26.38 Mean :3.969 Mean : 0.04743
## 3rd Qu.: 24.45 3rd Qu.:5.000 3rd Qu.: 0.33314
## Max. :933.57 Max. :7.000 Max. : 0.50000数値データのそれぞれのヒストグラム
done!
# numeric variables
num_vars <-
df %>%
select(where(is.numeric)) %>%
select(!ends_with(c("year", "month", "id", "tf", "code"))) %>%
colnames()
# define the function
# each
results <- lapply(num_vars,
FUN = function(n) {
# print(
ggplot(df, aes_string(n)) +
geom_histogram()
# )
}
)
# name the list
results <- `names<-`(results, num_vars)
# show
results## $sales
##
## $quantity
##
## $discount
##
## $profit
##
## $shipping_cost
##
## $gap_date
##
## $profit_ratio
discountについて
数値データの中で唯一のコントロールできる変数だから、深ぼっていきたい。
discout histgram
全体の65％ぐらいが、20％未満の割引なんだな。 割引しすぎてるってのが、問題なのかも。
df$discount %>% hist()
discount v.s. profit ratio
discout しすぎてネガティブになっているのは、渋くない？ 特に割引率が高すぎるものは、profitがネガティブになっているものもある。 そういうものって何なんだろう？どのような財？ 割引しないときは、どれくらいの利益率なのか？
もうすでにテーブルはデータから取り除いてしまって考えよう。
df %>%
filter(sub_category != "Tables") %>%
ggplot(aes(discount, profit_ratio)) +
geom_ref_line(h = 0) +
geom_jitter() +
geom_smooth(method = "lm") 
日付データのレンジ
データのレンジは、2018年1月1日から2021年12月31日まで。
# date range
df %>%
select(ends_with("date")) %>%
select(!gap_date) %>%
lapply(range)## $order_date
## [1] "2018-01-01" "2021-12-31"
##
## $ship_date
## [1] "2018-01-03" "2022-01-07"カテゴリカルデータの数
オーダー数とorder_idとの関係とは？これがはっきりしない。
総データのエントリー数が、row:51290なのに対して、customer_idは、1500程度しかない。 もしかしたら、繰り返し買っている顧客（お得意様）とそうでない新規顧客が存在するのではないか。 それぞれに対して別々のアプローチをとることで、利益率を改善させることができるかもしれない。
世界中の国々ついて述べるのは労力をともなうため、上位5か国とか、マーケットごとでまとめたほうがいいかもしれない。productについても同じことが言えそう。
order_priorityは、実際に利益率改善に役に立っているのか。どかも分析もできそう。
# check the number of unique categorical variables
df_tidy %>%
select(where(is.character)) %>%
lapply(unique) %>%
lapply(length)## $order_id
## [1] 25035
##
## $order_date
## [1] 1430
##
## $ship_date
## [1] 1464
##
## $ship_mode
## [1] 4
##
## $customer_id
## [1] 1590
##
## $customer_name
## [1] 795
##
## $segment
## [1] 3
##
## $city
## [1] 3636
##
## $state
## [1] 1094
##
## $country
## [1] 147
##
## $market
## [1] 7
##
## $region
## [1] 13
##
## $product_id
## [1] 10292
##
## $category
## [1] 3
##
## $sub_category
## [1] 17
##
## $product_name
## [1] 3788
##
## $order_priority
## [1] 4気になる変数とその関係
気になる変数を深堀していく。
月々のオーダーの数と出荷数
毎年11月、12月にかけてオーダー数が増えている。（？） シーズンによって商品のオーダー数が増えているかの確かめをしたほうがいいかも。 これ、オーダー数だけじゃなくて、profit, quantity, salesに対してもやったほうがいいな。
g1 <-
df %>%
mutate(colour = if_else(order_month %in% c(11, 12), "red", "blue")) %>%
group_by(order_year, order_month) %>%
ggplot() +
aes(order_date, fill = colour) +
geom_bar()
g1
2018年の例
ざっと見た感じ、11月、12月に注文数が多くなっているのがわかる。
df %>%
group_by(order_year, order_date) %>%
summarise(total = n()) %>% filter(order_year == 2018, total > 50) ## # A tibble: 31 × 3
## # Groups: order_year [1]
## order_year order_date total
## <dbl> <date> <int>
## 1 2018 2018-03-01 53
## 2 2018 2018-06-07 60
## 3 2018 2018-06-22 55
## 4 2018 2018-08-25 53
## 5 2018 2018-09-02 60
## 6 2018 2018-09-08 76
## 7 2018 2018-09-14 63
## 8 2018 2018-09-23 54
## 9 2018 2018-09-26 56
## 10 2018 2018-09-27 57
## # … with 21 more rowsオーダーを受けてから出荷するまでの日付に国ごとのばらつきはあるのか？
ない！
# there must be some variations in the gap between the order date and the ship date.
# Q. how is the gap between the order date and the ship date?
df %>%
ggplot(aes(gap_date, region)) +
geom_boxplot()
出荷費用に関しては、どのような国ごとのばらつきはあるのか？
# there must be some variations in the shipping cost across countries.
# Q. how much is that?
g_corporate <- df %>%
filter(segment == "Corporate") %>%
ggplot(aes(shipping_cost, market)) +
geom_boxplot() +
labs(title = "Corporate")
g_consumer <- df %>%
filter(segment == "Consumer") %>%
ggplot(aes(shipping_cost, market)) +
geom_boxplot() +
labs(title = "Consumer")
g_home_office <- df %>%
filter(segment == "Home Office") %>%
ggplot(aes(shipping_cost, market)) +
geom_boxplot() +
labs(title = "Home Office")
g_corporate / g_consumer / g_home_office
年毎の利益と地域
# basic info --------------------------------------------------------------
# the ration of regions in profit on the annual basis
df %>%
group_by(order_year, order_month, region) %>%
summarise(sum_profit = sum(profit)) %>%
ggplot(aes(order_year, sum_profit, fill = region)) +
geom_col()
年ごとの利益 （要検討）
# total profit by year
profit_by_year <-
df %>% group_by(order_year) %>%
summarise(annual_profit = sum(profit))
# profit ratio by year
df %>%
group_by(order_year, order_month, market) %>%
summarise(sum_profit = sum(profit)) %>%
mutate(profit_ratio_by_year = sum_profit/filter(profit_by_year, order_year == order_year)[[2]]) %>%
arrange(order_year, desc(sum_profit)) ## # A tibble: 335 × 5
## # Groups: order_year, order_month [48]
## order_year order_month market sum_profit profit_ratio_by_year
## <dbl> <dbl> <chr> <dbl> <dbl>
## 1 2018 9 EU 13805. 0.0555
## 2 2018 12 APAC 13516. 0.0442
## 3 2018 10 APAC 13496. 0.0441
## 4 2018 12 EU 11540. 0.0464
## 5 2018 11 US 9292. 0.0228
## 6 2018 6 APAC 9216. 0.0301
## 7 2018 12 US 8984. 0.0220
## 8 2018 11 APAC 8951. 0.0293
## 9 2018 9 US 8328. 0.0204
## 10 2018 6 EU 7799. 0.0313
## # … with 325 more rowsどのマーケットが一番儲かっているのか？
Especially the markets in APAc and EU are expanding.
# Q. the most profitable market, product, category, sub_category,
df %>%
group_by(order_year, market) %>%
summarise(profit = sum(profit)) %>%
arrange(order_year,desc(profit)) %>%
top_n(5, profit)## # A tibble: 20 × 3
## # Groups: order_year [4]
## order_year market profit
## <dbl> <chr> <dbl>
## 1 2018 APAC 83032.
## 2 2018 EU 61626.
## 3 2018 US 49544.
## 4 2018 LATAM 36708.
## 5 2018 Africa 10944.
## 6 2019 APAC 89321.
## 7 2019 EU 83775.
## 8 2019 US 61180.
## 9 2019 LATAM 49524.
## 10 2019 Africa 11909.
## 11 2020 APAC 123193.
## 12 2020 EU 98484.
## 13 2020 US 82165.
## 14 2020 LATAM 62077.
## 15 2020 Africa 26687.
## 16 2021 APAC 140454.
## 17 2021 EU 128944.
## 18 2021 US 93508.
## 19 2021 LATAM 73335.
## 20 2021 Africa 39331.どの国が特に利益を上げているのか？
The presence of China and India is growing.
# Q. which country?
df %>%
filter(market %in% c("APAC", "EU")) %>%
group_by(order_year, country) %>%
summarise(market_profit = sum(profit)) %>%
arrange(order_year, desc(market_profit)) %>%
top_n(3, market_profit)## # A tibble: 12 × 3
## # Groups: order_year [4]
## order_year country market_profit
## <dbl> <chr> <dbl>
## 1 2018 China 33181.
## 2 2018 United Kingdom 20080.
## 3 2018 India 19929.
## 4 2019 United Kingdom 27366.
## 5 2019 India 27329.
## 6 2019 China 26234.
## 7 2020 China 44474.
## 8 2020 India 33007.
## 9 2020 France 32316.
## 10 2021 India 48808.
## 11 2021 China 46794.
## 12 2021 United Kingdom 36756.インドと中国では特にどのsubcategoryが売れているのか？
technology, furniture, office suplliesで変らない。
# which category is sold in those region?
df %>%
filter(country %in% c("India", "China")) %>%
group_by(order_year, sub_category) %>%
summarise(profit_by_subcategory = sum(profit)) %>%
arrange(order_year, desc(profit_by_subcategory)) %>%
top_n(10, desc(profit_by_subcategory)) ## # A tibble: 40 × 3
## # Groups: order_year [4]
## order_year sub_category profit_by_subcategory
## <dbl> <chr> <dbl>
## 1 2018 Machines 2599.
## 2 2018 Furnishings 2008.
## 3 2018 Envelopes 1187.
## 4 2018 Supplies 1073.
## 5 2018 Binders 1022.
## 6 2018 Art 819.
## 7 2018 Paper 763.
## 8 2018 Fasteners 478.
## 9 2018 Labels 224.
## 10 2018 Tables -1465.
## # … with 30 more rows大手取引先はいるのか？
いるが、それぞれがバラバラ。もっとフォローアップを増やし、one-timeではなく、継続的な大手取引先を作るべき。
df %>%
group_by(order_year, customer_id) %>%
summarise(profit_by_customer = sum(profit)) %>%
arrange(order_year, desc(profit_by_customer)) %>%
top_n(10, profit_by_customer) ## # A tibble: 40 × 3
## # Groups: order_year [4]
## order_year customer_id profit_by_customer
## <dbl> <chr> <dbl>
## 1 2018 SC-20095 5716.
## 2 2018 CA-11965 3121.
## 3 2018 NM-18445 2950.
## 4 2018 GT-14710 2909.
## 5 2018 ON-18715 2689.
## 6 2018 ER-13855 2618.
## 7 2018 TB-21400 2549.
## 8 2018 KN-16390 2453.
## 9 2018 HL-15040 2405.
## 10 2018 RB-19330 2238.
## # … with 30 more rows過去4年間でそれぞれの顧客が支配的な割合を占めているのか？
ggplot(df, aes(x =))
大手取引先の属性情報は？
# top10 customers customer's id for every year.
major_customers <-
df %>%
group_by(order_year, customer_id) %>%
summarise(profit_by_customer = sum(profit)) %>%
arrange(order_year, desc(profit_by_customer)) %>%
top_n(10, profit_by_customer) %>%
ungroup() %>%
select(customer_id) %>%
unlist() %>%
unname()
df %>%
filter(customer_id %in% major_customers) %>%
group_by(order_year, customer_id, sub_category) %>%
summarise(profit_by_subcategory = sum(profit)) %>%
arrange(order_year, desc(profit_by_subcategory)) %>%
top_n(1, profit_by_subcategory)## # A tibble: 152 × 4
## # Groups: order_year, customer_id [152]
## order_year customer_id sub_category profit_by_subcategory
## <dbl> <chr> <chr> <dbl>
## 1 2018 SC-20095 Binders 5480.
## 2 2018 CA-11965 Phones 2939.
## 3 2018 ER-13855 Appliances 2476.
## 4 2018 TB-21400 Machines 2240.
## 5 2018 ON-18715 Chairs 2125.
## 6 2018 NM-18445 Machines 1996.
## 7 2018 HL-15040 Phones 1930.
## 8 2018 DR-12940 Appliances 1644.
## 9 2018 KN-16390 Tables 1528.
## 10 2018 GT-14710 Chairs 1474.
## # … with 142 more rows5ページの構成
page1: Overview of the trends of quantities, order counts, sales, and profits（問題発見）
これはtabuleauでやったほうが早いかも。
売り上げは毎年上昇している。そして利益も上昇している。ここには問題はなさそう。 ただ、利益率は下がっているように見える。
df_tem <-
df %>%
group_by(order_year) %>%
summarise(sales_year = sum(sales), shipping_cost_year = sum(shipping_cost), profit_year = sum(profit)) %>%
pivot_longer(cols = c(sales_year, shipping_cost_year, profit_year), names_to = "vars", values_to = "value") %>%
mutate(vars = factor(vars, levels = c("sales_year", "shipping_cost_year", "profit_year")))
g_pg1_1 <-
df_tem %>%
filter(vars == "sales_year") %>%
ggplot(aes(x = factor(order_year), y = value, group = vars), colour = "green") +
geom_point() +
geom_line() +
scale_y_continuous(labels = scales::label_number(accracy = 1))
g_pg1_2 <-
df_tem %>%
filter(vars %in% c("shipping_cost_year", "profit_year")) %>%
ggplot(aes(x = factor(order_year), y = value, colour = vars, group = vars)) +
geom_point() +
geom_line() +
scale_y_continuous(labels = scales::label_number(accuracy = 1))
g_pg1_1 / g_pg1_2
quantityの推移
3年で2倍程度になっている。目覚ましい成長。ってことは、qには問題がなさそう。
df %>%
group_by(order_year) %>%
summarise(quantity_year = sum(quantity)) %>%
ggplot(aes(order_year, quantity_year)) +
geom_point() +
geom_line() +
scale_y_continuous(labels = scales::number_format(accuracy = 1))
利益率の推移
言うほど利益率が上昇している感じでもないのかな。 0.110あたりで推移しているイメージ。 salesの値が上昇しているから、コストが上昇しているわけではないのか。あくまでも比例的にprofitはsalesに対して伸びているのか。 ってことは、規模の経済が働いていない可能性を示唆している。
利益率を改善するにはってのが、一つの課題ではあるな。
g_pg1_3 <-
df %>%
group_by(order_year) %>%
summarise(profit_ratio_year = sum(profit)/sum(sales)) %>%
ggplot(aes(order_year, profit_ratio_year)) +
geom_point() +
geom_line()
g_pg1_3
page2: What is the most profitable/less profitable product subcategory? （解決策1の提示）
table
table <-
df %>%
group_by(order_year, sub_category) %>%
summarise(profit_ratio_year = sum(profit)/sum(sales)) %>%
arrange(order_year, desc(profit_ratio_year))
# show the table
DT::datatable(table,
rownames = FALSE,
extensions = 'Buttons',
options = list(autoWidth = TRUE,
pageLength = 5,
dom = 'Bfrtip',
buttons = list("csv"),
scrollX = TRUE,
scrollCollapse = TRUE),
class = 'cell-border stripe'
)graph
テーブルがありえんくらい利益率低いな。 これ売らないほうがいいんじゃない？
# graph
g_pg2_1 <-
table %>%
ggplot(aes(factor(order_year), profit_ratio_year, colour = sub_category, group = sub_category)) +
geom_point() +
geom_line()
plotly::ggplotly(g_pg2_1)もしもテーブルを売らなかったら利益率はどの程度改善するのか？
テーブルの販売はやめたほうがいいですね。
g_pg2_2 <-
df %>%
group_by(order_year) %>%
summarise(profit_ratio_year_with = sum(profit)/sum(sales)) %>%
left_join(by = "order_year",
df %>%
filter(sub_category != "Tables") %>%
group_by(order_year) %>%
summarise(profit_ratio_year_without = sum(profit)/sum(sales))
) %>%
pivot_longer(cols = c(profit_ratio_year_with, profit_ratio_year_without)) %>%
ggplot(aes(order_year, value, colour = name, group = name)) +
geom_point() +
geom_line(aes(linetype = name))
# show
g_pg2_2
もしもテーブルを売らなかったら利益はどの程度改善するのか？
さすがに利益自体は減ってしまうのか。 テーブルを売るお金をほかの在庫に回せた場合、って分析もありかな？ テーブルに使ったお金（sales）がほかの商品であった場合、というか、平均的な利益率を達成した場合の利益の増加分を計測してみようかな。
あと、これ月ごとの分析にしてもいいかもしれない。
g_pg2_3 <-
df %>%
group_by(order_year) %>%
summarise(profit_year_with = sum(profit)) %>%
left_join(by = "order_year",
df %>%
filter(sub_category != "Tables") %>%
group_by(order_year) %>%
summarise(profit_year_without = sum(profit))
) %>%
pivot_longer(cols = c(profit_year_with, profit_year_without)) %>%
ggplot(aes(order_year, value, colour = name, group = name)) +
geom_point() +
geom_line(aes(linetype = name)) +
scale_y_continuous(labels = scales::number_format(accuracy = 1))
# show
g_pg2_3
page3: Is the discout effective? （解決策2）
テーブルは、もうないものとして考えよう。(いや、やっぱり入れておこう） それでも、discoutが大きくなると、profit_ratioが少なくなってしまう傾向があるな。 つまり、全体的に言って、財の種類でいうと非弾力的ってことかな？ もしかしたら、値段を上げたほうが利益率は改善するのかもしれない。
g_pg3_1 <-
df %>%
# filter(sub_category != "Tables") %>%
ggplot(aes(discount, profit_ratio)) +
geom_ref_line(h = 0) +
geom_jitter() +
geom_smooth(method = "lm")
g_pg3_1
それぞれのsubcategoryごとのdiscount v.s. profit ratio
これは、全体的に同じ傾向か。
df %>%
# filter(sub_category != "Tables") %>%
ggplot(aes(discount, profit_ratio, colour = sub_category)) +
geom_ref_line(h = 0) +
geom_jitter() +
geom_smooth(method = "lm") +
facet_wrap(vars(sub_category)) +
theme(legend.position = "none")
それぞれのsubcategoryごとのdiscount v.s. quantity
実際に、このデータからわかることは、価格の変動に対して需要が非弾力的。
df %>%
filter(sub_category != "Tables") %>%
ggplot(aes(discount, quantity, colour = sub_category)) +
geom_ref_line(h = 0) +
geom_jitter() +
geom_smooth(method = "lm") +
facet_wrap(vars(sub_category)) +
theme(legend.position = "none")
それぞれのsubcategoryごとのdiscount v.s. profit
profitのほうが見ていて面白そうだな。 結局、discountにかかわらず、利益が変わらないから意味がないって言えるしね。
df %>%
filter(sub_category != "Tables") %>%
ggplot(aes(discount, profit, colour = sub_category)) +
geom_ref_line(h = 0) +
geom_jitter() +
geom_smooth(method = "lm") +
facet_wrap(vars(sub_category)) +
theme(legend.position = "none")
subcategoryごとのregresssionの結果
v.s quantity
下の図は、discountを説明変数とし、quantityを被説明変数としたときの単回帰分析をした時の係数を入れてある。
- strorage
- fasteres
- art
- copiers
- paper
関しては、discoutをしようが、しまいが、quantityが変わっていない。つまり、95％信頼区間の中で、discoutをしても意味がないといえるだろう。
これ、年ごとのやつを作ってもいいかもしれないな。
ただし、売れない商品をもしかしたらdiscountしているのかもしれないため、discountしたから、売上数量が減ったという原因と結果を表しているわけではないことに注意するべきである。
# nest the dataeset based on the sub_category
df_lm <- df %>%
group_by(sub_category) %>%
nest()
# name the columns
names(df_lm$data) <- df_lm$sub_category # name the list of the data in df_lm
# run the regression
df_lm <- df_lm %>%
mutate(model = purrr::map(data, ~ estimatr::lm_robust(quantity ~ discount, data = .))) # run the robust regression
# create vars for plotting data
coefficient <- c()
p_value <- c()
sd_error <- c()
for (i in 1:length(df_lm$sub_category)) {
coefficient[i] <- df_lm$model[i][[1]]$coefficients[2]
p_value[i] <- df_lm$model[i][[1]]$p.value[2]
sd_error[i] <- df_lm$model[i][[1]]$std.error[2]
}
# create a data frame for plotting error bar
df_graphics <- tibble(
sub_category = df_lm$sub_category,
coefficient = coefficient,
p_value = p_value,
sd_error = sd_error,
ci_lower = coefficient - 1.96*sd_error,
ci_upper = coefficient + 1.96*sd_error,
p_logical = if_else(p_value > 0.05, "p>0.05", "p<=0.05")
) %>%
left_join(df %>% group_by(sub_category) %>% summarise(profit_ratio = sum(profit)/sum(sales))) # add profit ratio
# plot with ggplot2
df_graphics %>%
ggplot(aes(profit_ratio,
coefficient,
colour = p_logical)) +
geom_point() +
geom_hline(yintercept = 0, alpha = 0.25, linetype = "dashed") +
geom_errorbar(aes(ymin = ci_lower, ymax = ci_upper)) +
ggrepel::geom_text_repel(aes(label = df_lm$sub_category), check_overlap = TRUE) +
scale_color_manual(values = c("#ff9980", "#33ccff")) +
labs(title = "quantity = Beta_0 + Beta_1 * discount + epsilon",
subtitle = str_wrap("", 80),
x = "Profit Ratio",
y = "Coefficient (annual quantity)",
) +
theme_minimal() +
theme(legend.position = "right")
v.s profit
下の図は、discountを説明変数とし、profitを被説明変数としたときの単回帰分析をした時の係数を入れてある。 discountによって確実に利益は下がっている。これは、おおよそpriceが下がってしまっているからだろう。 しかし、価格弾力的な材に関しては、cost一定だと仮定すると、priceの上昇によって、
ほとんどの商品に関して、discoutをしようが、しまいが、profitが変わっていない。つまり、95％信頼区間の中で、discoutをしても意味がないといえるだろう。
# nest the dataeset based on the sub_category
df_lm <- df %>%
group_by(sub_category) %>%
nest()
# name the columns
names(df_lm$data) <- df_lm$sub_category # name the list of the data in df_lm
# run the regression
df_lm <- df_lm %>%
mutate(model = purrr::map(data, ~ estimatr::lm_robust(profit ~ discount, data = .))) # run the robust regression
# create vars for plotting data
coefficient <- c()
p_value <- c()
sd_error <- c()
for (i in 1:length(df_lm$sub_category)) {
coefficient[i] <- df_lm$model[i][[1]]$coefficients[2]
p_value[i] <- df_lm$model[i][[1]]$p.value[2]
sd_error[i] <- df_lm$model[i][[1]]$std.error[2]
}
# create a data frame for plotting error bar
df_graphics <- tibble(
sub_category = df_lm$sub_category,
coefficient = coefficient,
p_value = p_value,
sd_error = sd_error,
ci_lower = coefficient - 1.96*sd_error,
ci_upper = coefficient + 1.96*sd_error,
p_logical = if_else(p_value > 0.05, "p>0.05", "p<=0.05")
) %>%
left_join(df %>% group_by(sub_category) %>% summarise(profit_ratio = sum(profit)/sum(sales))) # add profit ratio
# plot with ggplot2
df_graphics %>%
ggplot(aes(profit_ratio,
coefficient,
colour = p_logical)) +
geom_point() +
geom_hline(yintercept = 0, alpha = 0.25, linetype = "dashed") +
geom_errorbar(aes(ymin = ci_lower, ymax = ci_upper)) +
ggrepel::geom_text_repel(aes(label = df_lm$sub_category), check_overlap = TRUE) +
scale_color_manual(values = c("#ff9980", "#33ccff")) +
labs(title = "profit = Beta_0 + Beta_1 * discount + epsilon",
subtitle = str_wrap("", 80),
x = "Profit Ratio",
y = "Coefficient (annual profit)",
) +
theme_minimal() +
theme(legend.position = "right")
page4: country/region/market
page5:
最後に、、、
興味のある方は以下のQRコードを参照して、サイトにアクセスしてみてください。
qrcode::qr_code("https://htmlpreview.github.io/?https://raw.githubusercontent.com/Ricky-s-a/business_analysis/main/report/prep_for_coursework_2022_23.html") %>% plot()